home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / Src / Ch17 / BumpSph.cls < prev    next >
Text File  |  1999-07-09  |  18KB  |  597 lines

  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "RayBumpySphere"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = False
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. ' A sphere object with bump texturing.
  17.  
  18. Implements RayTraceable
  19.  
  20. ' Geometry.
  21. Private Radius As Single
  22. Private Center As Point3D
  23.  
  24. Private Const NUM_THETA = 10
  25. Private Const NUM_PHI = 10
  26. Private WireFrame(1 To NUM_THETA, 1 To NUM_PHI) As Point3D
  27.  
  28. ' Bumpiness.
  29. Private Bumpiness As Single
  30.  
  31. ' Ambient light parameters.
  32. Private AmbientKr As Single
  33. Private AmbientKg As Single
  34. Private AmbientKb As Single
  35.  
  36. ' Diffuse light parameters.
  37. Private DiffuseKr As Single
  38. Private DiffuseKg As Single
  39. Private DiffuseKb As Single
  40.  
  41. ' Specular reflection parameters.
  42. Private SpecularN As Single
  43. Private SpecularK As Single
  44.  
  45. ' Reflected light parameters.
  46. Private ReflectedKr As Single
  47. Private ReflectedKg As Single
  48. Private ReflectedKb As Single
  49.  
  50. ' Refracted light parameters.
  51. Private TransN As Single
  52. Private n1 As Single   ' Index of refraction outside the object.
  53. Private n2 As Single   ' Index of refraction inside the object.
  54. Private TransmittedKr As Single
  55. Private TransmittedKg As Single
  56. Private TransmittedKb As Single
  57.  
  58. Private IsReflective As Boolean
  59. Private IsTransparent As Boolean
  60. Private DoneOnThisScanline As Boolean
  61.  
  62. ' We had a hit on this scanline.
  63. Private HadHit As Boolean
  64.  
  65. ' We have had a hit on a previous scanline.
  66. Private HadHitOnPreviousScanline As Boolean
  67.  
  68. ' We will not be visible on later scanlines.
  69. Private ForeverCulled As Boolean
  70. ' Return the right shade for this polygon.
  71. Private Function GetShade(ByVal pgon As SimplePolygon) As Long
  72. Dim i As Integer
  73. Dim px As Single
  74. Dim py As Single
  75. Dim pz As Single
  76. Dim light_source As LightSource
  77. Dim total_r As Single
  78. Dim total_g As Single
  79. Dim total_b As Single
  80. Dim R1 As Integer
  81. Dim g1 As Integer
  82. Dim b1 As Integer
  83. Dim empty_objects As Collection
  84.  
  85.     With pgon
  86.         ' Find a central point on this polygon.
  87.         For i = 1 To .PointX.Count
  88.             px = px + .PointX(i)
  89.             py = py + .PointY(i)
  90.             pz = pz + .PointZ(i)
  91.         Next i
  92.         px = px / .PointX.Count
  93.         py = py / .PointX.Count
  94.         pz = pz / .PointX.Count
  95.  
  96.         ' Add up the light components.
  97.         Set empty_objects = New Collection
  98.         For Each light_source In LightSources
  99.             CalculateHitColorDSA _
  100.                 1, empty_objects, Nothing, _
  101.                 EyeX, EyeY, EyeZ, _
  102.                 px, py, pz, .Nx, .Ny, .Nz, _
  103.                 DiffuseKr, DiffuseKg, DiffuseKb, AmbientKr, AmbientKg, AmbientKb, _
  104.                 SpecularK, SpecularN, R1, g1, b1
  105.             total_r = total_r + R1
  106.             total_g = total_g + g1
  107.             total_b = total_b + b1
  108.         Next light_source
  109.     End With
  110.  
  111.     If total_r > 255 Then total_r = 255
  112.     If total_g > 255 Then total_g = 255
  113.     If total_b > 255 Then total_b = 255
  114.  
  115.     GetShade = RGB(total_r, total_g, total_b)
  116. End Function
  117. ' Draw a face if it is not a backface.
  118. Private Sub DrawFace(ByVal pic As PictureBox, X() As Single, Y() As Single, Z() As Single)
  119. Dim pgon As SimplePolygon
  120. Dim i As Integer
  121.  
  122.     ' Make a polygon.
  123.     Set pgon = New SimplePolygon
  124.     For i = 1 To 4
  125.         pgon.AddPoint X(i), Y(i), Z(i)
  126.     Next i
  127.     pgon.Finish
  128.  
  129.     ' If it is not a backface, draw it.
  130.     If Not pgon.IsBackface() Then
  131.         pgon.ForeColor = GetColor()
  132.         pgon.DrawPolygon pic
  133.     End If
  134. End Sub
  135. ' Add non-backface polygons to this collection.
  136. Public Sub RayTraceable_GetPolygons(ByRef num_polygons As Integer, polygons() As SimplePolygon, ByVal shaded As Boolean)
  137. Dim t As Integer
  138. Dim P As Integer
  139. Dim last_t As Integer
  140. Dim pgon As SimplePolygon
  141. Dim i As Integer
  142. Dim color As Long
  143.  
  144.     ' If all polygons are the same color,
  145.     ' get an appropriate color.
  146.     If Not shaded Then
  147.         color = GetColor()
  148.     End If
  149.  
  150.     last_t = NUM_THETA
  151.     For t = 1 To NUM_THETA
  152.         For P = 1 To NUM_PHI - 1
  153.             ' Make a polygon.
  154.             Set pgon = New SimplePolygon
  155.             With WireFrame(last_t, P)
  156.                 pgon.AddPoint .Trans(1), .Trans(2), .Trans(3)
  157.             End With
  158.             With WireFrame(t, P)
  159.                 pgon.AddPoint .Trans(1), .Trans(2), .Trans(3)
  160.             End With
  161.             With WireFrame(t, P + 1)
  162.                 pgon.AddPoint .Trans(1), .Trans(2), .Trans(3)
  163.             End With
  164.             With WireFrame(last_t, P + 1)
  165.                 pgon.AddPoint .Trans(1), .Trans(2), .Trans(3)
  166.             End With
  167.             pgon.Finish
  168.  
  169.             ' See if this is a backface.
  170.             If Not pgon.IsBackface() Then
  171.                 ' This is not a backface. Add it to
  172.                 ' the list.
  173.                 With pgon
  174.                     ' See if we are shaded.
  175.                     If shaded Then
  176.                         ' We are shaded. Get the
  177.                         ' right color.
  178.                         .ForeColor = GetShade(pgon)
  179.                         .FillColor = .ForeColor
  180.                     Else
  181.                         ' We are not shaded. Use the
  182.                         ' normal colors.
  183.                         .ForeColor = vbBlack
  184.                         .FillColor = color
  185.                     End If
  186.                     num_polygons = num_polygons + 1
  187.                     ReDim Preserve polygons(1 To num_polygons)
  188.                     Set polygons(num_polygons) = pgon
  189.                 End With
  190.             End If
  191.         Next P
  192.         last_t = t
  193.     Next t
  194. End Sub
  195. ' Make a wire frame.
  196. Private Sub MakeWireFrame()
  197. Const PI = 3.14159265
  198.  
  199. Dim i_theta As Integer
  200. Dim i_phi As Integer
  201. Dim theta As Single
  202. Dim phi As Single
  203. Dim dtheta As Single
  204. Dim dphi As Single
  205. Dim X As Single
  206. Dim Y As Single
  207. Dim Z As Single
  208. Dim rad As Single
  209.  
  210.     dtheta = 2 * PI / NUM_THETA
  211.     dphi = PI / (NUM_PHI - 1)
  212.     theta = 0
  213.     For i_theta = 1 To NUM_THETA
  214.         phi = -PI / 2
  215.         For i_phi = 1 To NUM_PHI
  216.             Z = Center.Coord(3) + Radius * Sin(phi)
  217.             rad = Radius * Cos(phi)
  218.             X = Center.Coord(1) + rad * Cos(theta)
  219.             Y = Center.Coord(2) + rad * Sin(theta)
  220.  
  221.             WireFrame(i_theta, i_phi).Coord(1) = X
  222.             WireFrame(i_theta, i_phi).Coord(2) = Y
  223.             WireFrame(i_theta, i_phi).Coord(3) = Z
  224.             WireFrame(i_theta, i_phi).Coord(4) = 1
  225.  
  226.             phi = phi + dphi
  227.         Next i_phi
  228.         theta = theta + dtheta
  229.     Next i_theta
  230. End Sub
  231.  
  232. ' Return an appropriate color for this object.
  233. Private Function GetColor() As Long
  234. Dim R As Integer
  235. Dim G As Integer
  236. Dim B As Integer
  237.  
  238.     R = 255 * (DiffuseKr + AmbientKr): If R > 255 Then R = 255
  239.     G = 255 * (DiffuseKg + AmbientKg): If G > 255 Then G = 255
  240.     B = 255 * (DiffuseKb + AmbientKb): If B > 255 Then B = 255
  241.     GetColor = RGB(R, G, B)
  242. End Function
  243.  
  244. ' Initialize the object using text parameters in
  245. ' a comma-delimited list.
  246. Public Sub SetParameters(ByVal txt As String)
  247.     On Error GoTo SphereParamError
  248.  
  249.     ' Read the parameters and initialize the object.
  250.     ' Geometry.
  251.     Radius = CSng(GetDelimitedToken(txt, ","))
  252.     Center.Coord(1) = CSng(GetDelimitedToken(txt, ","))
  253.     Center.Coord(2) = CSng(GetDelimitedToken(txt, ","))
  254.     Center.Coord(3) = CSng(GetDelimitedToken(txt, ","))
  255.     Center.Coord(4) = 1
  256.  
  257.     ' Bumpiness.
  258.     Bumpiness = CSng(GetDelimitedToken(txt, ","))
  259.  
  260.     ' Ambient light.
  261.     AmbientKr = CSng(GetDelimitedToken(txt, ","))
  262.     AmbientKg = CSng(GetDelimitedToken(txt, ","))
  263.     AmbientKb = CSng(GetDelimitedToken(txt, ","))
  264.  
  265.     ' Diffuse reflection.
  266.     DiffuseKr = CSng(GetDelimitedToken(txt, ","))
  267.     DiffuseKg = CSng(GetDelimitedToken(txt, ","))
  268.     DiffuseKb = CSng(GetDelimitedToken(txt, ","))
  269.  
  270.     ' Specular reflection.
  271.     SpecularN = CSng(GetDelimitedToken(txt, ","))
  272.     SpecularK = CSng(GetDelimitedToken(txt, ","))
  273.  
  274.     ' Reflected light.
  275.     ReflectedKr = CSng(GetDelimitedToken(txt, ","))
  276.     ReflectedKg = CSng(GetDelimitedToken(txt, ","))
  277.     ReflectedKb = CSng(GetDelimitedToken(txt, ","))
  278.     IsReflective = (ReflectedKr > 0) Or (ReflectedKg > 0) Or (ReflectedKb > 0)
  279.  
  280.     ' Transmitted light.
  281.     TransN = CSng(GetDelimitedToken(txt, ","))
  282.     n1 = CSng(GetDelimitedToken(txt, ","))
  283.     n2 = CSng(GetDelimitedToken(txt, ","))
  284.     TransmittedKr = CSng(GetDelimitedToken(txt, ","))
  285.     TransmittedKg = CSng(GetDelimitedToken(txt, ","))
  286.     TransmittedKb = CSng(GetDelimitedToken(txt, ","))
  287.     IsTransparent = (TransmittedKr > 0) Or (TransmittedKg > 0) Or (TransmittedKb > 0)
  288.  
  289.     ' Make a wire frame.
  290.     MakeWireFrame
  291.  
  292.     Exit Sub
  293.  
  294. SphereParamError:
  295.     MsgBox "Error initializing sphere parameters."
  296. End Sub
  297.  
  298. ' Draw a wireframe for this object.
  299. Public Sub RayTraceable_DrawWireFrame(ByVal pic As PictureBox)
  300. Dim t As Integer
  301. Dim P As Integer
  302. Dim last_t As Integer
  303.  
  304.     ' Use an appropriate color.
  305.     pic.ForeColor = GetColor()
  306.  
  307.     last_t = NUM_THETA
  308.     For t = 1 To NUM_THETA
  309.         For P = 1 To NUM_PHI
  310.             With WireFrame(last_t, P)
  311.                 pic.CurrentX = .Trans(1)
  312.                 pic.CurrentY = .Trans(2)
  313.             End With
  314.             With WireFrame(t, P)
  315.                 pic.Line -(.Trans(1), .Trans(2))
  316.             End With
  317.             If P < NUM_PHI Then
  318.                 With WireFrame(t, P + 1)
  319.                     pic.Line -(.Trans(1), .Trans(2))
  320.                 End With
  321.             End If
  322.         Next P
  323.         last_t = t
  324.     Next t
  325. End Sub
  326. ' Draw the object with backfaces removed.
  327. Public Sub RayTraceable_DrawBackfacesRemoved(ByVal pic As PictureBox)
  328. Dim t As Integer
  329. Dim P As Integer
  330. Dim last_t As Integer
  331. Dim X(1 To 4) As Single
  332. Dim Y(1 To 4) As Single
  333. Dim Z(1 To 4) As Single
  334.  
  335.     ' Use an appropriate color.
  336.     pic.ForeColor = GetColor()
  337.  
  338.     last_t = NUM_THETA
  339.     For t = 1 To NUM_THETA
  340.         For P = 1 To NUM_PHI - 1
  341.             With WireFrame(last_t, P)
  342.                 X(1) = .Trans(1)
  343.                 Y(1) = .Trans(2)
  344.                 Z(1) = .Trans(3)
  345.             End With
  346.             With WireFrame(t, P)
  347.                 X(2) = .Trans(1)
  348.                 Y(2) = .Trans(2)
  349.                 Z(2) = .Trans(3)
  350.             End With
  351.             With WireFrame(t, P + 1)
  352.                 X(3) = .Trans(1)
  353.                 Y(3) = .Trans(2)
  354.                 Z(3) = .Trans(3)
  355.             End With
  356.             With WireFrame(last_t, P + 1)
  357.                 X(4) = .Trans(1)
  358.                 Y(4) = .Trans(2)
  359.                 Z(4) = .Trans(3)
  360.             End With
  361.  
  362.             DrawFace pic, X, Y, Z
  363.         Next P
  364.         last_t = t
  365.     Next t
  366. End Sub
  367. ' Apply a transformation matrix to the object.
  368. Public Sub RayTraceable_Apply(M() As Single)
  369. Dim i_theta As Integer
  370. Dim i_phi As Integer
  371.  
  372.     ' Transform the wire frame.
  373.     For i_theta = 1 To NUM_THETA
  374.         For i_phi = 1 To NUM_PHI
  375.             m3Apply WireFrame(i_theta, i_phi).Coord, _
  376.                  M, WireFrame(i_theta, i_phi).Trans
  377.         Next i_phi
  378.     Next i_theta
  379.  
  380.     ' Transform the center.
  381.     m3Apply Center.Coord, M, Center.Trans
  382. End Sub
  383. ' Apply a transformation matrix to the object.
  384. Public Sub RayTraceable_ApplyFull(M() As Single)
  385. Dim i_theta As Integer
  386. Dim i_phi As Integer
  387.  
  388.     ' Transform the wire frame.
  389.     For i_theta = 1 To NUM_THETA
  390.         For i_phi = 1 To NUM_PHI
  391.             m3ApplyFull WireFrame(i_theta, i_phi).Coord, _
  392.                      M, WireFrame(i_theta, i_phi).Trans
  393.         Next i_phi
  394.     Next i_theta
  395.  
  396.     ' Transform the center.
  397.     m3ApplyFull Center.Coord, M, Center.Trans
  398. End Sub
  399.  
  400. ' Return the red, green, and blue components of
  401. ' the surface at the hit position.
  402. Public Sub RayTraceable_FindHitColor( _
  403.     ByVal depth As Integer, Objects As Collection, _
  404.     ByVal eye_x As Single, ByVal eye_y As Single, ByVal eye_z As Single, _
  405.     ByVal px As Single, ByVal py As Single, ByVal pz As Single, _
  406.     ByRef R As Integer, ByRef G As Integer, ByRef B As Integer)
  407. Dim Nx As Single
  408. Dim Ny As Single
  409. Dim Nz As Single
  410. Dim n_len  As Single
  411.  
  412.     ' Find the unit normal at this point.
  413.     Nx = px - Center.Trans(1)
  414.     Ny = py - Center.Trans(2)
  415.     Nz = pz - Center.Trans(3)
  416.     n_len = Sqr(Nx * Nx + Ny * Ny + Nz * Nz)
  417.     Nx = Nx / n_len
  418.     Ny = Ny / n_len
  419.     Nz = Nz / n_len
  420.  
  421.     ' Randommize the normal a little bit and
  422.     ' renormalize.
  423.     Nx = Nx + Rnd * Bumpiness
  424.     Ny = Ny + Rnd * Bumpiness
  425.     Nz = Nz + Rnd * Bumpiness
  426.     n_len = Sqr(Nx * Nx + Ny * Ny + Nz * Nz)
  427.     Nx = Nx / n_len
  428.     Ny = Ny / n_len
  429.     Nz = Nz / n_len
  430.  
  431.     ' Get the hit color.
  432.     CalculateHitColor depth, Objects, Me, _
  433.         eye_x, eye_y, eye_z, _
  434.         px, py, pz, _
  435.         Nx, Ny, Nz, _
  436.         DiffuseKr, DiffuseKg, DiffuseKb, _
  437.         AmbientKr, AmbientKg, AmbientKb, _
  438.         SpecularK, SpecularN, _
  439.         ReflectedKr, ReflectedKg, ReflectedKb, IsReflective, _
  440.         TransmittedKr, TransmittedKg, TransmittedKb, TransN, n1, n2, IsTransparent, _
  441.         R, G, B
  442. End Sub
  443. ' See if the scanline plane with the indicated
  444. ' point and normal intersects this object. Set
  445. ' the object's DoneOnThisScanline flag appropriately.
  446. Public Sub RayTraceable_CullScanline(ByVal px As Single, ByVal py As Single, ByVal pz As Single, ByVal Nx As Single, ByVal Ny As Single, ByVal Nz As Single)
  447. Dim dx As Single
  448. Dim dy As Single
  449. Dim dz As Single
  450. Dim dist As Single
  451.  
  452.     ' See if we will ever be visible again.
  453.     If ForeverCulled Then
  454.         DoneOnThisScanline = True
  455.         Exit Sub
  456.     End If
  457.  
  458.     ' We have not yet had a hit on this scanline.
  459.     HadHit = False
  460.  
  461.     ' Find the distance from the center of the
  462.     ' sphere to the scanline plane.
  463.  
  464.     ' Get the vector from our center to the point.
  465.     With Center
  466.         dx = .Trans(1) - px
  467.         dy = .Trans(2) - py
  468.         dz = .Trans(3) - pz
  469.     End With
  470.  
  471.     ' Take the dot product of this and the normal.
  472.     ' If the resulting distance > Radius, cull.
  473.     DoneOnThisScanline = (Abs(dx * Nx + dy * Ny + dz * Nz) > Radius)
  474.  
  475.     ' See if we will be culled in the future.
  476.     If DoneOnThisScanline Then
  477.         ' We were not culled on a previous scanline
  478.         ' but we are now. We will be culled on
  479.         ' all later scanlines.
  480.         If HadHitOnPreviousScanline Then ForeverCulled = True
  481.     Else
  482.         ' We are not culled. Remember that.
  483.         HadHitOnPreviousScanline = True
  484.     End If
  485. End Sub
  486. ' Return the value T for the point of intersection
  487. ' between the vector from point (px, py, pz) in
  488. ' the direction <vx, vy, vz>.
  489. '
  490. ' direct_calculation is true if we are finding the
  491. ' intersection from a viewing position ray. It is
  492. ' false if we are finding an reflected intersection
  493. ' or a shadow feeler.
  494. Public Function RayTraceable_FindT(ByVal direct_calculation As Boolean, ByVal px As Single, ByVal py As Single, ByVal pz As Single, ByVal Vx As Single, ByVal Vy As Single, ByVal Vz As Single) As Single
  495. Dim A As Single
  496. Dim B As Single
  497. Dim C As Single
  498. Dim Cx As Single
  499. Dim Cy As Single
  500. Dim Cz As Single
  501. Dim B24AC As Single
  502. Dim t1 As Single
  503. Dim t2 As Single
  504. Dim dx As Single
  505. Dim dy As Single
  506. Dim dz As Single
  507.  
  508.     ' See if we have been culled.
  509.     If direct_calculation And DoneOnThisScanline Then
  510.         RayTraceable_FindT = -1
  511.         Exit Function
  512.     End If
  513.  
  514.     Cx = Center.Trans(1)
  515.     Cy = Center.Trans(2)
  516.     Cz = Center.Trans(3)
  517.  
  518.     ' Get the coefficients for the quadratic.
  519.     A = Vx * Vx + Vy * Vy + Vz * Vz
  520.     B = 2 * Vx * (px - Cx) + _
  521.         2 * Vy * (py - Cy) + _
  522.         2 * Vz * (pz - Cz)
  523.     C = Cx * Cx + Cy * Cy + Cz * Cz + _
  524.         px * px + py * py + pz * pz - _
  525.         2 * (Cx * px + Cy * py + Cz * pz) - _
  526.         Radius * Radius
  527.  
  528.     ' Solve the quadratic A*t^2 + B*t + C = 0.
  529.     B24AC = B * B - 4 * A * C
  530.     If B24AC < 0 Then
  531.         ' There is no real intersection.
  532.         RayTraceable_FindT = -1
  533.  
  534.         ' If we had a hit before on this scanline
  535.         ' but we don't have one now. We are done
  536.         ' for this scanline.
  537.         If HadHit And direct_calculation Then DoneOnThisScanline = True
  538.  
  539.         Exit Function
  540.     ElseIf B24AC = 0 Then
  541.         ' There is one intersection.
  542.         t1 = -B / 2 / A
  543.     Else
  544.         ' There are two intersections.
  545.         B24AC = Sqr(B24AC)
  546.         t1 = (-B + B24AC) / 2 / A
  547.         t2 = (-B - B24AC) / 2 / A
  548.         ' Use only positive t values.
  549.         If t1 < 0.01 Then t1 = t2
  550.         If t2 < 0.01 Then t2 = t1
  551.         ' Use the smaller t value.
  552.         If t1 > t2 Then t1 = t2
  553.     End If
  554.  
  555.     ' If there is no positive t value, there's no
  556.     ' intersection in this direction.
  557.     If t1 < 0.01 Then
  558.         RayTraceable_FindT = -1
  559.  
  560.         ' If we had a hit before on this scanline
  561.         ' but we don't have one now. We are done
  562.         ' for this scanline.
  563.         If HadHit And direct_calculation Then DoneOnThisScanline = True
  564.  
  565.         Exit Function
  566.     End If
  567.  
  568.     ' We had a hit.
  569.     If direct_calculation Then HadHit = True
  570.  
  571.     RayTraceable_FindT = t1
  572. End Function
  573.  
  574. ' Return the minimum and maximum distances from
  575. ' this point.
  576. Private Sub RayTraceable_GetRminRmax(new_min As Single, new_max As Single, ByVal X As Single, ByVal Y As Single, ByVal Z As Single)
  577. Dim dx As Single
  578. Dim dy As Single
  579. Dim dz As Single
  580. Dim dist As Single
  581.  
  582.     dx = X - Center.Trans(1)
  583.     dy = Y - Center.Trans(2)
  584.     dz = Z - Center.Trans(3)
  585.     dist = Sqr(dx * dx + dy * dy + dz * dz)
  586.     new_max = dist + Radius
  587.     new_min = dist - Radius
  588.     If new_min < 0 Then new_min = 0
  589. End Sub
  590. ' Reset the ForeverCulled flag.
  591. Private Sub RayTraceable_ResetCulling()
  592.     ForeverCulled = False
  593.     HadHitOnPreviousScanline = False
  594. End Sub
  595.  
  596.  
  597.